home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 68.7z / BS1 part 68 / InterChange Plus v3.0 (1993-11)(Syndesis)(Disk 2 of 2).7z / InterChange Plus v3.0 (1993-11)(Syndesis)(Disk 2 of 2).adf / PC_Tools.LZH / ALISP.ZIP / EXBLOCK.LSP < prev    next >
Lisp/Scheme  |  1993-10-06  |  12KB  |  313 lines
  1. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
  2. ³                                                                             ³
  3. ³                                EXBLOCK.LSP                                  ³
  4. ³                                                                             ³
  5. ³           Don Brown            Version 0.9             7/24/90              ³
  6. ³                                                                             ³
  7. ³    "EX" -  Explodes unequal  X/Y/Z  scale blocks.                           ³
  8. ³                                                                             ³
  9. ³    Erases the selected block.  It then procedes to recreate the block from  ³
  10. ³    scratch.  It does this by looking in the TABLES for the block, then goes ³
  11. ³    through each entity, one by one.                                         ³
  12. ³                                                                             ³
  13. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
  14.  
  15. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ Main Routine ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  16. (defun c:ex (/ osmode fltlnd cmdeko ent ent-gt)
  17.     (setq osmode (getvar "osmode")
  18.           fltlnd (getvar "flatland")
  19.           cmdeko (getvar "cmdecho"))
  20.     (setvar "osmode" 0)
  21.     (setvar "flatland" 0)
  22.     (setvar "cmdecho" 0)
  23.     (setq ent (entsel))
  24.     (if ent (progn
  25.         (setq ent-gt (entget (car ent)))
  26.         (if (= "INSERT" (~fld 0 ent-gt))
  27.             (~doit ent-gt)
  28.             (princ "\n\7Entity isn't a block!")
  29.         )
  30.  
  31.     ))
  32.     (setvar "osmode" osmode)
  33.     (setvar "flatland" fltlnd)
  34.     (setvar "cmdecho" cmdeko)
  35.     (princ)
  36. )
  37.  
  38. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ Dxf Extractor ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  39. (defun ~fld (num temp)  (cdr (assoc num temp)))
  40.  
  41. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ Radians to Degrees converter ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  42. (defun ~rtd (temp)  (* 180.0 (/ temp pi)))
  43.  
  44. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ Midpoint of 2 points ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  45. (defun ~mid (A B) (mapcar '(lambda (I J) (/ (+ I J) 2)) A B))
  46.  
  47. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ Converts old point to new point ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  48. (defun ~newpt (old-pt / newpt dist angl)
  49.     (setq newpt (list
  50.                     (* (car old-pt) x-scal)
  51.                     (* (cadr old-pt) y-scal)
  52.                     (* (caddr old-pt) z-scal)
  53.                 )
  54.           dist (distance blkins newpt)
  55.           angl (angle blkins newpt)
  56.     )
  57.     (polar ins-pt (+ rot-an angl) dist)
  58. )
  59.  
  60. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ Sets the Linetype, Elevation Thickness & Color ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  61. (defun ~sets (entity)
  62.     (command "linetype" "s"
  63.         (if (~fld 6 entity) (~fld 6 entity) "bylayer")
  64.         "")
  65.     (command "elev"  (if (~fld 38 entity) (* elevat (~fld 38 entity)) 0.0)
  66.                      (if (~fld 39 entity) (* thick (~fld 39 entity)) 0.0))
  67.     (command "color" (if (~fld 62 entity) (~fld 62 entity) "bylayer"))
  68. )
  69.  
  70. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ This part does all the work ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  71. (defun ~doit (entity)
  72.     (princ "\nOk...It's a block!\n\n")
  73. ;   Remove the following semi-colon to erase original block
  74. ;    (command ".erase" (~fld -1 entity) "")
  75.     (setq bl-nam (~fld 2 entity)     ;\
  76.           elevat (~fld 38 entity)    ;  \
  77.           thick (~fld 39 entity)     ;    \
  78.           ins-pt (~fld 10 entity)    ;      \  Entity's sets
  79.           rot-an (~fld 50 entity)    ;      /
  80.           x-scal   (~fld 41 entity)  ;    /
  81.           y-scal   (~fld 42 entity)  ;  /
  82.           z-scal   (~fld 43 entity)  ;/
  83.     )
  84.     (if (null thick) (setq thick 0.0))
  85.     (if (null elevat) (setq elevat 0.0))
  86.     (setq bl-def (tblsearch "BLOCK" bl-nam)
  87.           nxtent (~fld -2 bl-def)             ;first entity
  88.           blkins (~fld 10 bl-def)
  89.     )
  90.     (while nxtent
  91.         (setq nxtget (entget nxtent)
  92.               enttyp (~fld 0 nxtget)
  93.         )
  94.         (~sets nxtget)
  95.         (cond
  96.             ((= enttyp "3DFACE")  (princ "\n3DFACE")        (~3dface))
  97.             ((= enttyp "3DLINE")  (princ "\n3DLINE")        (~point))
  98.             ((= enttyp "ARC")     (princ "\nARC")           (~arc))
  99.             ((= enttyp "ATTDEF")  (princ "\nATTDEF")    (princ "...Not supported (yet)"))
  100.             ((= enttyp "ATTRIB")  (princ "\nATTRIB")    (princ "...Not supported (yet)"))
  101.             ((= enttyp "CIRCLE")  (princ "\nCIRCLE")
  102.                 (command ".ellipse" "C"
  103.                     (~newpt (~fld 10 nxtget))
  104.                     (~newpt (polar (~fld 10 nxtget) 0 (~fld 40 nxtget)))
  105.                     (~newpt (polar (~fld 10 nxtget) (/ pi 2.0) (~fld 40 nxtget)))
  106.                 ))
  107.             ((= enttyp "DIMENSION")   (princ "\nDIMENSION") (~dimen))
  108.             ((= enttyp "INSERT")      (princ "\nINSERT")    (~insrt))
  109.             ((= enttyp "LINE")        (princ "\nLINE")      (~point))
  110.             ((= enttyp "POINT")       (princ "\nPOINT")     (~point))
  111.             ((= enttyp "POLYLINE")    (princ "\nPOLYLINE")  (~pline))
  112.             ((= enttyp "SHAPE")       (princ "\nSHAPE")
  113.                 (command ".shape"
  114.                     (~fld 2 nxtget)
  115.                     (~newpt (~fld 10 nxtget))
  116.                     (* x-scal (~fld 40 nxtget))
  117.                     (~rtd (+ rot-an (~fld 50 nxtget)))
  118.                 )
  119.             )
  120.             ((= enttyp "SOLID")       (princ "\nSOLID")     (~point))
  121.             ((= enttyp "TEXT")        (princ "\nTEXT")      ;(~text)
  122.             )
  123.             ((= enttyp "TRACE")       (princ "\nTRACE")
  124.                 (command ".TRACE"
  125.                         (distance   (~newpt (~fld 10 nxtget))
  126.                                     (~newpt (~fld 11 nxtget)))
  127.                         (~mid       (~newpt (~fld 10 nxtget))
  128.                                     (~newpt (~fld 11 nxtget)))
  129.                         (~mid       (~newpt (~fld 12 nxtget))
  130.                                     (~newpt (~fld 13 nxtget)))
  131.                         ""
  132.                 )
  133.             )
  134.             ((= enttyp "VERTEX")       (princ "\nVERTEX")     (~vertex))
  135.             (T
  136.                 (princ enttyp)
  137.                 (princ "\n")
  138.                 (princ nxtget)
  139.             ) ;end T
  140.         )
  141.  
  142.         (setq nxtent (entnext nxtent))
  143.     )
  144. )
  145. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ 3D FACES ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  146. (defun ~3dface ( / face face-1 face-2 face-3 face-4)
  147.     (command ".3dface")
  148.     (setq face (~fld 70 nxtget)
  149.           face-4 (if (>= face 8) (progn (setq face (- face 8)) T) nil)
  150.           face-3 (if (>= face 4) (progn (setq face (- face 4)) T) nil)
  151.           face-2 (if (>= face 2) (progn (setq face (- face 2)) T) nil)
  152.           face-1 (if (>= face 1) (progn (setq face (- face 1)) T) nil)
  153.     )
  154.     (if face-1 (command "i"))
  155.     (command (~newpt (~fld 10 nxtget)))
  156.     (if face-2 (command "i"))
  157.     (command (~newpt (~fld 11 nxtget)))
  158.     (if face-3 (command "i"))
  159.     (command (~newpt (~fld 12 nxtget)))
  160.     (if face-4 (command "i"))
  161.     (command (~newpt (~fld 13 nxtget)) "")
  162. )
  163. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ARC ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  164. (defun ~arc ( / p1 p2)
  165.     (command ".ellipse" "C"
  166.         (~newpt (~fld 10 nxtget))
  167.         (~newpt (polar (~fld 10 nxtget) 0 (~fld 40 nxtget)))
  168.         (~newpt (polar (~fld 10 nxtget) (/ pi 2.0) (~fld 40 nxtget)))
  169.     )
  170.     (setq ell (entlast))
  171.     (command
  172.         ".line"
  173.         (setq p1 (~newpt (polar (~fld 10 nxtget) (~fld 51 nxtget) (~fld 40 nxtget))))
  174.         (setq p2 (~newpt (polar (~fld 10 nxtget) (~fld 50 nxtget) (~fld 40 nxtget))))
  175.         ""
  176.         ".change" (entlast) "" (polar p1 (angle p2 p1) 5)
  177.         ".change" (entlast) "" (polar p2 (angle p1 p2) 5)
  178.     )
  179.     (setq line (entlast)
  180.           p1 (~fld 50 nxtget)
  181.           p2 (~fld 51 nxtget))
  182.     (command
  183.         ".trim" line ""
  184.         (list ell
  185.             (~newpt
  186.                 (polar
  187.                     (~fld 10 nxtget)
  188.                     (+ rot-an pi
  189.                         (/ (+ p1 p2
  190.                               (if (> p1 p2)
  191.                                 (* pi 2.0)
  192.                                 0.0
  193.                               ) ;enf if
  194.                            ) ;end +
  195.                            2.0
  196.                         ) ;end /
  197.                     ) ;end +
  198.                     (~fld 40 nxtget)
  199.                 ) ;end polar
  200.             ) ;end ~newpt
  201.         ) ;end list
  202.         ""
  203.     ) ;end command
  204.     (entdel line)
  205. )
  206. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ Dimension ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  207. (defun ~dimen (/ kind)
  208.     (princ nxtget)
  209.     (setq kind (~fld 70 nxtget))
  210.     (command ".dim" "rot"
  211.         (cond
  212.             ((= kind 0) "rotated"
  213.                         (~rtd (+ rot-an (~fld 50 nxtget)))
  214.             )
  215.             ((= kind 1) "aligned")
  216.             ((= kind 2) "angular")
  217.             ((= kind 3) "diameter")
  218.             ((= kind 4) "radius")
  219.         )
  220.         (~newpt (~fld 10 nxtget))
  221.         (~newpt (~fld 13 nxtget))
  222.         (~newpt (~fld 11 nxtget))
  223.         (if (~fld 1 nxtget) (~fld 1 nxtget) "")
  224.     "exit")
  225. )
  226. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ INSERT ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  227. (defun ~insrt ()
  228.     (command ".insert"
  229.         (~fld 2 nxtget)
  230.         (~newpt (~fld 10 nxtget))
  231.         "XYZ"
  232.         (* x-scal (~fld 41 nxtget))
  233.         (* y-scal (~fld 42 nxtget))
  234.         (* z-scal (~fld 43 nxtget))
  235.         (~rtd (+ rot-an (~fld 50 nxtget)))
  236.     )
  237.     (if (~fld 66 nxtget)
  238.         (princ "...Attributes of blocks not supported (yet).")
  239.     )
  240. )
  241. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ POINTS ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  242. (defun ~point ()
  243.     (command (strcat "." (~fld 0 nxtget)))
  244.     (if (~fld 10 nxtget) (command (~newpt (~fld 10 nxtget))))
  245.     (if (~fld 11 nxtget) (command (~newpt (~fld 11 nxtget))))
  246.     (if (~fld 12 nxtget) (command (~newpt (~fld 12 nxtget))))
  247.     (if (~fld 13 nxtget) (command (~newpt (~fld 13 nxtget))))
  248.     (command)
  249. )
  250. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  251. (defun ~text (/ height angl)
  252.     (getstring)
  253.     (setvar "cmdecho" 1)
  254.     (setq height (* y-scal (~fld 40 nxtget))
  255.           angl (~rtd (+ rot-an (~fld 50 nxtget))))
  256.     (Command ".text" "s" (~fld 7 nxtget))
  257.     (mem)
  258.     (cond
  259.         ((= (~fld 72 nxtget) 0)
  260.             (command        (~newpt (~fld 10 nxtget))
  261.                             height angl)
  262.         )
  263.         ((= (~fld 72 nxtget) 1)
  264.             (command   "C"  (~newpt (~fld 10 nxtget))
  265.                             height angl)
  266.         )
  267.         ((= (~fld 72 nxtget) 2)
  268.             (command   "R"  (~newpt (~fld 10 nxtget))
  269.                             height angl)
  270.         )
  271.         ((= (~fld 72 nxtget) 3)
  272.             (command   "A"  (~newpt (~fld 10 nxtget))
  273.                             (~newpt (~fld 11 nxtget)))
  274.         )
  275.         ((= (~fld 72 nxtget) 4)
  276.             (command   "M"  (~newpt (~fld 10 nxtget))
  277.                             height angl)
  278.         )
  279.         ((= (~fld 72 nxtget) 5)
  280.             (command   "F"  (~newpt (~fld 10 nxtget))
  281.                             (~newpt (~fld 11 nxtget))
  282.                             height angl)
  283.         )
  284.     ) ;end cond
  285. )
  286. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ Pline ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  287. (Defun ~pline ()
  288.     (setq   p-type (~fld 70 nxtget)
  289.             pmeshm (~fld 71 nxtget)
  290.             pmeshn (~fld 72 nxtget)
  291.             smeshn (~fld 73 nxtget)
  292.             smeshn (~fld 74 nxtget)
  293.             swidth (~fld 41 nxtget)
  294.             ewidth (~fld 42 nxtget)
  295.             smooth (~fld 75 nxtget)
  296.     )
  297.     (if (>= p-type 32) (Setq closen T p-type (- p-type 32)) (setq closen nil))
  298.     (if (>= p-type 16) (Setq pmesh  T p-type (- p-type 16)) (setq pmesh nil))
  299.     (if (>= p-type 8)  (Setq pline  T p-type (- p-type 8))  (setq pline nil))
  300.     (if (>= p-type 4)  (Setq spline T p-type (- p-type 4))  (setq spline nil))
  301.     (if (>= p-type 2)  (Setq curve  T p-type (- p-type 2))  (setq curve nil))
  302.     (if (>= p-type 1)  (Setq closem T p-type (- p-type 1))  (setq closem nil))
  303. )
  304. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  305. (defun ~vertex ()
  306.     (princ "\tStill under production...")
  307. )
  308. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
  309.  
  310. (princ "loaded.")
  311. (trace ~text)
  312. (C:ex)
  313.